# Copyright (c) 2010-2015 Trevor L. Davis <trevor.l.davis@stanford.edu>
# Copyright (c) 2015 Rick FitzJohn https://github.com/richfitz
# Copyright (c) 2013 Kirill Müller https://github.com/krlmlr
# Copyright (c) 2011 Jim Nikelski <nikelski@bic.mni.mcgill.ca>
# Copyright (c) 2010 Steve Lianoglou <lianos@cbio.mskcc.org>
#
#  This file is free software: you may copy, redistribute and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation, either version 2 of the License, or (at your
#  option) any later version.
#
#  This file is distributed in the hope that it will be useful, but
#  WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#  General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# This file incorporates work from the optparse module in Python 2.6.2.
#
#     Copyright (c) 1990-2009 Python Software Foundation; All Rights Reserved
#
# See (inst/)COPYRIGHTS or http://docs.python.org/2/license.html for the full
# Python (GPL-compatible) license stack.
#
# As mentioned above, this file incorporates some patches by Steve Lianoglou (c) 2010
# He explicitly gave me a non-exclusive unlimited license to code in his patches

setClass("OptionParser", representation(usage = "character", options = "list",
                description="character", epilogue="character"))


OptionParserOption <- setClass("OptionParserOption", representation(short_flag="character",
                                    long_flag="character",
                                    action="character",
                                    type="character",
                                    dest="character",
                                    default="ANY",
                                    help="character",
                                    metavar="character"),)


OptionParser <- function(usage = "usage: %prog [options]", option_list=list(),
                            add_help_option=TRUE, prog=NULL,
                            description="", epilogue="") {

    if(is.null(prog)) {
        prog <- get_Rscript_filename()
    }
    if(length(prog) && !is.na(prog)) {
        usage <- gsub("%prog", prog, usage)
        description <- gsub("%prog", prog, description)
        epilogue <- gsub("%prog", prog, epilogue)
    }
    # Match behavior of usage string in Python optparse package
    usage <- sub("^usage: ", "Usage: ", usage)
    usage <- ifelse(grepl("^Usage: ", usage), usage, sub("^", "Usage: ", usage))
    if(add_help_option) {
        option_list[[length(option_list) + 1]] <-
            make_option(c("-h", "--help"),
                action="store_true", dest="help", default=FALSE,
                help="Show this help message and exit")
    }

    return(new("OptionParser", usage=usage, options=option_list,
                    description=description, epilogue=epilogue))
}


make_option <- function(opt_str, action="store", type=NULL,
                     dest=NULL, default=NULL, help="", metavar=NULL) {
    # flags
    short_flag <- opt_str[grepl("^-[[:alpha:]]", opt_str)]
    if(length(short_flag)) {} else { short_flag <- as.character(NA) }
    long_flag <- opt_str[grepl("^--[[:alpha:]]", opt_str)]
    if(length(long_flag)) {} else {stop("We require a long flag option")}

    # type
    if(is.null(type)) {
        if( action %in% c("store_true", "store_false") ) {
            type <- "logical"
        }
        else {
            if( action %in% c("store") ) {
                if (is.null(default)) {
                    type <- "character"
                } else {
                    type <- typeof(default)
                }
            }
        }
    }
    if (type == "numeric") { type <- "double" }
    # default
    if((type != typeof(default)) & !is.null(default)) {
        storage.mode(default) <- type
    }
    # dest
    if(is.null(dest)) { dest <- sub("^--", "", long_flag) }
    # metavar
    if(is.null(metavar)) {
        if(action == "store") {
            metavar <- sub("^--", "", long_flag)
        } else {
            metavar <- character(0)
        }
    }

    return(new("OptionParserOption", short_flag=short_flag, long_flag=long_flag,
                        action=action, type=type, dest=dest, default=default,
                        help=help, metavar=metavar))
}

add_option <- function(object, opt_str, action="store", type=NULL,
                    dest=NULL, default=NULL, help="", metavar=NULL) {
    options_list <- object@options
    n_original_options <- length(options_list)
    options_list[[n_original_options + 1]] <- make_option(opt_str=opt_str,
                                           action=action, type=type, dest=dest,
                                           default=default, help=help, metavar=metavar)
    object@options <- options_list
    return(object)
}


print_help <- function(object) {
    cat(object@usage, fill = TRUE)
    cat(object@description, fill=TRUE)
    cat("\n")
    cat("Options:", sep="\n")

    options_list <- object@options
    for(ii in seq_along(options_list)) {
        option <- options_list[[ii]]
        cat("\t")
        if(!is.na(option@short_flag)) {
            cat(option@short_flag)
            if( option@action == "store" ) {
                cat(" ", toupper(option@metavar), sep="")
            }
            cat(", ")
        }
        if(!is.null(option@long_flag)) {
            cat(option@long_flag)
            if( option@action == "store" ) {
                cat("=", toupper(option@metavar), sep="")
            }
        }
        cat("\n\t\t")
        cat(sub("%default", .as_string(option@default), option@help))
        cat("\n\n")
    }
    cat(object@epilogue, fill=TRUE)
    return(invisible(NULL))
}


.as_string <- function(default) {
    if(is.null(default)) {
        default_str <- "NULL"
    } else if(!length(default)) {
        default_str <- paste0(typeof(default), "(0)")
    } else if(is.na(default)) {
        default_str <- "NA"
    } else {
        default_str <- as.character(default)
    }
}

parse_args <- function(object, args = commandArgs(trailingOnly = TRUE),
                    print_help_and_exit = TRUE, positional_arguments = FALSE) {

    n_options <- length( object@options )

    # Convert our option specification into ``getopt`` format
    spec <- matrix(NA, nrow = n_options, ncol = 5)
    for (ii in seq_along(object@options)) {
        spec[ii, ] <- .convert_to_getopt( object@options[[ii]] )
    }

    # pull out positional arguments if ``positional_arguments`` was set to TRUE
    # or not 0 or c(0, 0)
    if(!(length(positional_arguments) %in% 1L:2L))
        stop("positional_arguments must have length 1 or 2")
    if(is.logical(positional_arguments)) {
        if(positional_arguments) {
            positional_arguments <- c(0, Inf)
            include_any_args <- TRUE
        } else {
            include_any_args <- FALSE
        }
    } else if(is.numeric(positional_arguments)) {
        include_any_args <- TRUE
    } else {
        stop("positional_arguments must be logical or numeric")
    }

    arguments_positional <- character(0)
    if(max(positional_arguments) > 0) {
        os_and_n_arg <- .get_option_strings_and_n_arguments(object)
        original_arguments <- args
        args <- NULL
        is_taken <- FALSE # set to true if optional argument needs to take next argument
        for(argument in original_arguments) {
            if(is_taken) {
                args <- c(args, argument)
                is_taken <- FALSE
            } else {
                if(.is_option_string(argument, object)) {
                    args <- c(args, argument)
                    if(.requires_argument(argument, object))
                        is_taken <- TRUE
                } else {
                    arguments_positional <- c(arguments_positional, argument)
                }
            }
        }
    }

    options_list <- list()
    if(length(args)) {
        opt <- getopt(spec=spec, opt=args)
    } else {
        opt <- list()
    }

    for (ii in seq_along(object@options)) {
        option <- object@options[[ii]]
        option_value <- opt[[sub("^--", "", option@long_flag)]]
        if( !is.null(option_value) ) {
            if ( option@action == "store_false" ) {
                options_list[[option@dest]] <- FALSE
            } else {
                options_list[[option@dest]] <- option_value
            }
        } else {
            if( !is.null(option@default) & is.null(options_list[[option@dest]]) ) {
                options_list[[option@dest]] <- option@default
            }
        }
    }
    if(options_list[["help"]] & print_help_and_exit) {
        print_help(object)
        if(interactive()) stop("help requested") else quit(status=1)
    }
    if (length(arguments_positional) < min(positional_arguments)) {
      stop(sprintf("required at least %g positional arguments, got %g",
                   min(positional_arguments), length(arguments_positional)))
    }
    if (length(arguments_positional) > max(positional_arguments)) {
      stop(sprintf("required at most %g positional arguments, got %g",
                   max(positional_arguments), length(arguments_positional)))
    }
    if(include_any_args) {
        return(list(options = options_list, args = arguments_positional))
    } else {
        return(options_list)
    }
}

.is_option_string <- function(argument, object) {
    if(.is_long_flag(argument)) {
        if(grepl("=", argument)) {
            argument <- sub("(.*?)=.*", "\\1", argument)
        }
        return(argument %in% .get_long_options(object))
    } else if(.is_short_flag(argument)) {
        return(all(.expand_short_option(argument) %in% .get_short_options(object)))
    } else {
        return(FALSE)
    }
}

.requires_argument <- function(argument, object) {
    if(.is_long_flag(argument)) {
        if(grepl("=", argument)) {
            return(FALSE)
        } else {
            for (ii in seq_along(object@options)) {
                option <- object@options[[ii]]
                if(option@long_flag == argument)
                    return(option@action == "store")
            }
        }
    } else { # is a short flag
        last_flag <- tail(.expand_short_option(argument), 1)
        for (ii in seq_along(object@options)) {
            option <- object@options[[ii]]
            if(!is.na(option@short_flag) && option@short_flag == last_flag)
                return(option@action == "store")
        }
    }
}

.is_long_flag <- function(argument) { return(grepl("^--", argument)) }
.is_short_flag <- function(argument) { return(grepl("^-[^-]", argument)) }
.get_long_options <- function(object) {
    long_options <- vector("character")
    for(ii in seq_along(object@options)) {
        long_options <- c(long_options, object@options[[ii]]@long_flag)
    }
    return(long_options)
}
.get_short_options <- function(object) {
    short_options <- vector("character")
    for(ii in seq_along(object@options)) {
        short_options <- c(short_options, object@options[[ii]]@short_flag)
    }
    return(short_options)
}

.expand_short_option <- function(argument) {
    if(nchar(argument) == 2) {
        return(argument)
    } else {
        argument <- substr(argument, 2, nchar(argument)) # remove leading dash
        argument <- strsplit(argument, "")[[1]] # split into individual characters
        argument <- paste("-", argument, sep="") # add leading dash to each short option
        return(argument)
    }
}

.get_option_strings_and_n_arguments <- function(object) {
    option_strings <- vector("character")
    n_arguments <- vector("numeric")
    for (ii in seq_along(object@options)) {
        option <- object@options[[ii]]
        option_strings <- c(option_strings, option@short_flag)
        option_strings <- c(option_strings, option@long_flag)
        if (option@action == "store") {
            n_arguments <- c(n_arguments, 1, 1)
        } else {
            n_arguments <- c(n_arguments, 0, 0)
        }
    }
    return(list(option_strings = option_strings, n_arguments = n_arguments))
}

.convert_to_getopt <- function(object) {
    short_flag <- sub("^-", "", object@short_flag)
    long_flag <- sub("^--", "", object@long_flag)
    if( object@action %in% c("store_true", "store_false") ) {
        argument <- 0
    } else {
        argument <- 1
    }
    return( c( long_flag, short_flag, argument, object@type, object@help) )
}
